home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / m2menu.zip / MENU3.MOD < prev    next >
Encoding:
Text File  |  1990-03-23  |  16.5 KB  |  526 lines
  1.  MODULE menu3; (* Menu example, TopSpeed Modula-2 V 1.16 *)
  2.  
  3.  FROM IO     IMPORT  WrChar, WrLn, WrStr, WrStrAdj;
  4.  FROM Str    IMPORT  Length;
  5.  FROM Window IMPORT  Black, LightGray, White, Clear, Close, DoubleFrame,
  6.                      GotoXY, Open, TextColor, TextBackground, WinDef, WinType;
  7.  IMPORT MenuIO;
  8.  
  9.  CONST
  10.    DescLen  = 40;    (* max label length *)
  11.    Offset   = 1;
  12.  
  13.    NumMain  = 10;    (* total number of selections per menu *)
  14.    NumSub1  = 10;
  15.    NumSub2  = 10;
  16.    NumSub3  = 10;
  17.    NumSub4  = 10;
  18.    NumSub5  = 10;
  19.    NumSub6  = 10;
  20.    NumSub7  = 10;
  21.    NumSub8  = 10;
  22.    NumSub9  = 10;
  23.    NumSub10 = 10;
  24.  
  25.    up   = 310C;      (* input constants *)
  26.    down = 320C;
  27.    home = 307C;
  28.    end  = 317C;
  29.    pgup = 311C;
  30.    pgdn = 321C;
  31.    bel  = 7C;
  32.    esc  = 33C;
  33.    cr   = 15C;
  34.  
  35.  TYPE
  36.    xType = RECORD
  37.              ch: CHAR;
  38.              desc: ARRAY [0..DescLen] OF CHAR;
  39.            END;
  40.  VAR
  41.    MainMenu : ARRAY [0..NumMain-1] OF xType;
  42.    SubMenu1 : ARRAY [0..NumSub1-1] OF xType;
  43.    SubMenu2 : ARRAY [0..NumSub2-1] OF xType;
  44.    SubMenu3 : ARRAY [0..NumSub3-1] OF xType;
  45.    SubMenu4 : ARRAY [0..NumSub4-1] OF xType;
  46.    SubMenu5 : ARRAY [0..NumSub5-1] OF xType;
  47.    SubMenu6 : ARRAY [0..NumSub6-1] OF xType;
  48.    SubMenu7 : ARRAY [0..NumSub7-1] OF xType;
  49.    SubMenu8 : ARRAY [0..NumSub8-1] OF xType;
  50.    SubMenu9 : ARRAY [0..NumSub9-1] OF xType;
  51.    SubMenu10 : ARRAY [0..NumSub10-1] OF xType;
  52.  
  53.    Xch, sc : CHAR;
  54.  
  55.  (*********************************************************************)
  56.  (* Make a self-centering, self-wrapping moving bar menu              *)
  57.  (*********************************************************************)
  58.  
  59.  PROCEDURE MakeMenu(xArr: ARRAY OF xType): CHAR;
  60.  CONST
  61.    ScrDepth = 25;
  62.    ScrWidth = 80;
  63.  
  64.  VAR width, depth, left, top, right, bottom, i : CARDINAL;
  65.    getCH, result : CHAR;
  66.    MenuWin : WinType;
  67.    WD, smWD : WinDef;
  68.    xWidth: INTEGER;
  69.  
  70.    PROCEDURE HighLight(j: CARDINAL);
  71.    BEGIN
  72.      TextColor(Black);
  73.      TextBackground(LightGray);
  74.        GotoXY(Offset,j+1);
  75.        WrChar(' ');
  76.        WrChar(xArr[j].ch);
  77.        WrStr("  ");
  78.        WrStrAdj(xArr[j].desc, xWidth);
  79.      TextColor(White);
  80.      TextBackground(Black)
  81.    END HighLight;
  82.  
  83.    PROCEDURE RemLight(j: CARDINAL);
  84.    BEGIN
  85.      GotoXY(Offset,j+1);
  86.      WrChar(' ');
  87.      WrChar(xArr[j].ch);
  88.      WrStr("  ");
  89.      WrStrAdj(xArr[j].desc, xWidth)
  90.    END RemLight;
  91.  
  92.    VAR j, len, maxLength: CARDINAL;
  93.  
  94.    BEGIN
  95.    maxLength := Length(xArr[0].desc);
  96.      FOR j := 1 TO HIGH(xArr) DO
  97.        len := Length(xArr[j].desc);
  98.        IF len > maxLength THEN
  99.          maxLength := len
  100.        END(*IF*)
  101.      END;(*FOR*)
  102.    width := maxLength+6;
  103.    depth := HIGH(xArr)+2;
  104.    left := (ScrWidth-width) DIV 2;
  105.    right := left+width;
  106.    top := (ScrDepth-depth) DIV 3;
  107.    bottom := top+depth;
  108.    xWidth := -INTEGER(width);
  109.    WITH WD DO
  110.      X1 := left;
  111.      Y1 := top;
  112.      X2 := right;
  113.      Y2 := bottom;
  114.      Foreground := White;
  115.      Background := Black;
  116.      CursorOn := FALSE;
  117.      WrapOn := FALSE;
  118.      Hidden := FALSE;
  119.      FrameOn := TRUE;
  120.      FrameDef:= DoubleFrame;
  121.      FrameFore:= White;
  122.      FrameBack:= Black
  123.    END;(*WITH*)
  124.      MenuWin := Open(WD);
  125.      FOR i := 1 TO HIGH(xArr) DO
  126.        WITH xArr[i] DO
  127.          WrLn;
  128.          WrChar(' ');
  129.          WrChar(ch);
  130.          WrStr("  ");
  131.          WrStr(desc)
  132.        END(*WITH*)
  133.      END;(*FOR*)
  134.  
  135.    i := 0;
  136.  
  137.    (* handle input *)
  138.  
  139.    LOOP
  140.      HighLight(i);
  141.      getCH := MenuIO.GetKey(sc);
  142.        CASE getCH OF
  143.          up : RemLight(i);
  144.               IF i = 0 THEN
  145.               i := HIGH(xArr);
  146.               ELSE
  147.                 DEC(i)
  148.               END;
  149.               HighLight(i)
  150.  
  151.      | down : RemLight(i);
  152.               IF i = HIGH(xArr) THEN
  153.               i := 0
  154.               ELSE
  155.                 INC(i)
  156.               END;
  157.               HighLight(i)
  158.  
  159.      | home : RemLight(i);
  160.               IF i > 0 THEN
  161.                 i := 0
  162.               END;
  163.               HighLight(i)
  164.  
  165.       | end : RemLight(i);
  166.               IF i < HIGH(xArr) THEN
  167.                 i := HIGH(xArr)
  168.               END;
  169.               HighLight(i)
  170.  
  171.      | pgup : RemLight(i);
  172.               IF i > 0 THEN
  173.                 i := 0
  174.               END;
  175.               HighLight(i)
  176.  
  177.      | pgdn : RemLight(i);
  178.                 IF i < HIGH(xArr) THEN
  179.               i := HIGH(xArr)
  180.               END;
  181.               HighLight(i)
  182.       | cr : result := xArr[i].ch; EXIT
  183.       | '0'..'9' : result := xArr[ORD(sc)-2].ch; EXIT
  184.       | esc : result := esc; EXIT
  185.      ELSE
  186.        WrChar(bel) (* honk if non-valid key is hit *)
  187.      END;(*CASE*)
  188.    END;(*LOOP*)
  189.    Close(MenuWin);
  190.    RETURN result;
  191.  END MakeMenu;
  192.  
  193.  (********************************************************************)
  194.  (* Menu labels                                                      *)
  195.  (********************************************************************)
  196.  
  197.  PROCEDURE MenuLabelNumbers(VAR xArr: ARRAY OF xType);
  198.  BEGIN
  199.    xArr[0].ch := '1';
  200.    xArr[1].ch := '2';
  201.    xArr[2].ch := '3';
  202.    xArr[3].ch := '4';
  203.    xArr[4].ch := '5';
  204.    xArr[5].ch := '6';
  205.    xArr[6].ch := '7';
  206.    xArr[7].ch := '8';
  207.    xArr[8].ch := '9';
  208.    xArr[9].ch := '0'
  209.  END MenuLabelNumbers;
  210.  
  211.  PROCEDURE MainMenuLabel(VAR xArr: ARRAY OF xType);
  212.  BEGIN
  213.    MenuLabelNumbers(xArr);
  214.    xArr[0].desc := "Item One";
  215.    xArr[1].desc := "Item Two";
  216.    xArr[2].desc := "Item Three";
  217.    xArr[3].desc := "Item Four";
  218.    xArr[4].desc := "Item Five";
  219.    xArr[5].desc := "Item Six";
  220.    xArr[6].desc := "Item Seven";
  221.    xArr[7].desc := "Item Eight";
  222.    xArr[8].desc := "Item Nine";
  223.    xArr[9].desc := "Item Ten"
  224.  END MainMenuLabel;
  225.  
  226.  PROCEDURE M1(VAR xArr: ARRAY OF xType);
  227.  BEGIN
  228.    MenuLabelNumbers(xArr);
  229.    xArr[0].desc := "SubMenu One, Selection One";
  230.    xArr[1].desc := "SubMenu One, Selection Two";
  231.    xArr[2].desc := "SubMenu One, Selection Three";
  232.    xArr[3].desc := "SubMenu One, Selection Four";
  233.    xArr[4].desc := "SubMenu One, Selection Five";
  234.    xArr[5].desc := "SubMenu One, Selection Six";
  235.    xArr[6].desc := "SubMenu One, Selection Seven";
  236.    xArr[7].desc := "SubMenu One, Selection Eight";
  237.    xArr[8].desc := "SubMenu One, Selection Nine";
  238.    xArr[9].desc := "SubMenu One, Selection Ten"
  239.  END M1;
  240.  
  241.  PROCEDURE M2(VAR xArr: ARRAY OF xType);
  242.  BEGIN
  243.    MenuLabelNumbers(xArr);
  244.    xArr[0].desc := "SubMenu Two, Selection One";
  245.    xArr[1].desc := "SubMenu Two, Selection Two";
  246.    xArr[2].desc := "SubMenu Two, Selection Three";
  247.    xArr[3].desc := "SubMenu Two, Selection Four";
  248.    xArr[4].desc := "SubMenu Two, Selection Five";
  249.    xArr[5].desc := "SubMenu Two, Selection Six";
  250.    xArr[6].desc := "SubMenu Two, Selection Seven";
  251.    xArr[7].desc := "SubMenu Two, Selection Eight";
  252.    xArr[8].desc := "SubMenu Two, Selection Nine";
  253.    xArr[9].desc := "SubMenu Two, Selection Ten"
  254.  END M2;
  255.  
  256.  PROCEDURE M3(VAR xArr: ARRAY OF xType);
  257.  BEGIN
  258.    MenuLabelNumbers(xArr);
  259.    xArr[0].desc := "SubMenu Three, Selection One";
  260.    xArr[1].desc := "SubMenu Three, Selection Two";
  261.    xArr[2].desc := "SubMenu Three, Selection Three";
  262.    xArr[3].desc := "SubMenu Three, Selection Four";
  263.    xArr[4].desc := "SubMenu Three, Selection Five";
  264.    xArr[5].desc := "SubMenu Three, Selection Six";
  265.    xArr[6].desc := "SubMenu Three, Selection Seven";
  266.    xArr[7].desc := "SubMenu Three, Selection Eight";
  267.    xArr[8].desc := "SubMenu Three, Selection Nine";
  268.    xArr[9].desc := "SubMenu Three, Selection Ten"
  269.  END M3;
  270.  
  271.  PROCEDURE M4(VAR xArr: ARRAY OF xType);
  272.  BEGIN
  273.    MenuLabelNumbers(xArr);
  274.    xArr[0].desc := "SubMenu Four, Selection One";
  275.    xArr[1].desc := "SubMenu Four, Selection Two";
  276.    xArr[2].desc := "SubMenu Four, Selection Three";
  277.    xArr[3].desc := "SubMenu Four, Selection Four";
  278.    xArr[4].desc := "SubMenu Four, Selection Five";
  279.    xArr[5].desc := "SubMenu Four, Selection Six";
  280.    xArr[6].desc := "SubMenu Four, Selection Seven";
  281.    xArr[7].desc := "SubMenu Four, Selection Eight";
  282.    xArr[8].desc := "SubMenu Four, Selection Nine";
  283.    xArr[9].desc := "SubMenu Four, Selection Ten"
  284.  END M4;
  285.  
  286.  PROCEDURE M5(VAR xArr: ARRAY OF xType);
  287.  BEGIN
  288.    MenuLabelNumbers(xArr);
  289.    xArr[0].desc := "SubMenu Five, Selection One";
  290.    xArr[1].desc := "SubMenu Five, Selection Two";
  291.    xArr[2].desc := "SubMenu Five, Selection Three";
  292.    xArr[3].desc := "SubMenu Five, Selection Four";
  293.    xArr[4].desc := "SubMenu Five, Selection Five";
  294.    xArr[5].desc := "SubMenu Five, Selection Six";
  295.    xArr[6].desc := "SubMenu Five, Selection Seven";
  296.    xArr[7].desc := "SubMenu Five, Selection Eight";
  297.    xArr[8].desc := "SubMenu Five, Selection Nine";
  298.    xArr[9].desc := "SubMenu Five, Selection Ten"
  299.  END M5;
  300.  
  301.  PROCEDURE M6(VAR xArr: ARRAY OF xType);
  302.  BEGIN
  303.    MenuLabelNumbers(xArr);
  304.    xArr[0].desc := "SubMenu Six, Selection One";
  305.    xArr[1].desc := "SubMenu Six, Selection Two";
  306.    xArr[2].desc := "SubMenu Six, Selection Three";
  307.    xArr[3].desc := "SubMenu Six, Selection Four";
  308.    xArr[4].desc := "SubMenu Six, Selection Five";
  309.    xArr[5].desc := "SubMenu Six, Selection Six";
  310.    xArr[6].desc := "SubMenu Six, Selection Seven";
  311.    xArr[7].desc := "SubMenu Six, Selection Eight";
  312.    xArr[8].desc := "SubMenu Six, Selection Nine";
  313.    xArr[9].desc := "SubMenu Six, Selection Ten"
  314.  END M6;
  315.  
  316.  PROCEDURE M7(VAR xArr: ARRAY OF xType);
  317.  BEGIN
  318.    MenuLabelNumbers(xArr);
  319.    xArr[0].desc := "SubMenu Seven, Selection One";
  320.    xArr[1].desc := "SubMenu Seven, Selection Two";
  321.    xArr[2].desc := "SubMenu Seven, Selection Three";
  322.    xArr[3].desc := "SubMenu Seven, Selection Four";
  323.    xArr[4].desc := "SubMenu Seven, Selection Five";
  324.    xArr[5].desc := "SubMenu Seven, Selection Six";
  325.    xArr[6].desc := "SubMenu Seven, Selection Seven";
  326.    xArr[7].desc := "SubMenu Seven, Selection Eight";
  327.    xArr[8].desc := "SubMenu Seven, Selection Nine";
  328.    xArr[9].desc := "SubMenu Seven, Selection Ten"
  329.  END M7;
  330.  
  331.  PROCEDURE M8(VAR xArr: ARRAY OF xType);
  332.  BEGIN
  333.    MenuLabelNumbers(xArr);
  334.    xArr[0].desc := "SubMenu Eight, Selection One";
  335.    xArr[1].desc := "SubMenu Eight, Selection Two";
  336.    xArr[2].desc := "SubMenu Eight, Selection Three";
  337.    xArr[3].desc := "SubMenu Eight, Selection Four";
  338.    xArr[4].desc := "SubMenu Eight, Selection Five";
  339.    xArr[5].desc := "SubMenu Eight, Selection Six";
  340.    xArr[6].desc := "SubMenu Eight, Selection Seven";
  341.    xArr[7].desc := "SubMenu Eight, Selection Eight";
  342.    xArr[8].desc := "SubMenu Eight, Selection Nine";
  343.    xArr[9].desc := "SubMenu Eight, Selection Ten"
  344.  END M8;
  345.  
  346.  PROCEDURE M9(VAR xArr: ARRAY OF xType);
  347.  BEGIN
  348.    MenuLabelNumbers(xArr);
  349.    xArr[0].desc := "SubMenu Nine, Selection One";
  350.    xArr[1].desc := "SubMenu Nine, Selection Two";
  351.    xArr[2].desc := "SubMenu Nine, Selection Three";
  352.    xArr[3].desc := "SubMenu Nine, Selection Four";
  353.    xArr[4].desc := "SubMenu Nine, Selection Five";
  354.    xArr[5].desc := "SubMenu Nine, Selection Six";
  355.    xArr[6].desc := "SubMenu Nine, Selection Seven";
  356.    xArr[7].desc := "SubMenu Nine, Selection Eight";
  357.    xArr[8].desc := "SubMenu Nine, Selection Nine";
  358.    xArr[9].desc := "SubMenu Nine, Selection Ten"
  359.  END M9;
  360.  
  361.  PROCEDURE M10(VAR xArr: ARRAY OF xType);
  362.  BEGIN
  363.    MenuLabelNumbers(xArr);
  364.    xArr[0].desc := "SubMenu Ten, Selection One";
  365.    xArr[1].desc := "SubMenu Ten, Selection Two";
  366.    xArr[2].desc := "SubMenu Ten, Selection Three";
  367.    xArr[3].desc := "SubMenu Ten, Selection Four";
  368.    xArr[4].desc := "SubMenu Ten, Selection Five";
  369.    xArr[5].desc := "SubMenu Ten, Selection Six";
  370.    xArr[6].desc := "SubMenu Ten, Selection Seven";
  371.    xArr[7].desc := "SubMenu Ten, Selection Eight";
  372.    xArr[8].desc := "SubMenu Ten, Selection Nine";
  373.    xArr[9].desc := "SubMenu Ten, Selection Ten"
  374.  END M10;
  375.  
  376.  (********************************************************************)
  377.  (* Execute menu selections                                          *)
  378.  (********************************************************************)
  379.  
  380.  PROCEDURE MenuAction(VAR xArr: ARRAY OF xType);
  381.  BEGIN
  382.     CASE Xch OF
  383.      '1': Xch := MakeMenu(SubMenu1);
  384.           CASE Xch OF
  385.              '0'..'9': Clear;
  386.                        WrStr("SubMenu 1");
  387.                        WrStr(", Selection ");
  388.                        WrChar(Xch);
  389.                        WrStr(": Executed!");
  390.                        WrLn;
  391.                        WrLn;
  392.                        MenuIO.ExecCmd('pause')
  393.           END;(*CASE*)
  394.   | '2': Xch := MakeMenu(SubMenu2);
  395.           CASE Xch OF
  396.              '0'..'9': Clear;
  397.                        WrStr("SubMenu 2");
  398.                        WrStr(", Selection ");
  399.                        WrChar(Xch);
  400.                        WrStr(": Executed!");
  401.                        WrLn;
  402.                        WrLn;
  403.                        MenuIO.ExecCmd('pause')
  404.           END;(*CASE*)
  405.   | '3': Xch := MakeMenu(SubMenu3);
  406.           CASE Xch OF
  407.              '0'..'9': Clear;
  408.                        WrStr("SubMenu 3");
  409.                        WrStr(", Selection ");
  410.                        WrChar(Xch);
  411.                        WrStr(": Executed!");
  412.                        WrLn;
  413.                        WrLn;
  414.                        MenuIO.ExecCmd('pause')
  415.           END;(*CASE*)
  416.   | '4': Xch := MakeMenu(SubMenu4);
  417.           CASE Xch OF
  418.              '0'..'9': Clear;
  419.                        WrStr("SubMenu 4");
  420.                        WrStr(", Selection ");
  421.                        WrChar(Xch);
  422.                        WrStr(": Executed!");
  423.                        WrLn;
  424.                        WrLn;
  425.                        MenuIO.ExecCmd('pause')
  426.           END;(*CASE*)
  427.   | '5': Xch := MakeMenu(SubMenu5);
  428.           CASE Xch OF
  429.              '0'..'9': Clear;
  430.                        WrStr("SubMenu 5");
  431.                        WrStr(", Selection ");
  432.                        WrChar(Xch);
  433.                        WrStr(": Executed!");
  434.                        WrLn;
  435.                        WrLn;
  436.                        MenuIO.ExecCmd('pause')
  437.           END;(*CASE*)
  438.   | '6': Xch := MakeMenu(SubMenu6);
  439.           CASE Xch OF
  440.              '0'..'9': Clear;
  441.                        WrStr("SubMenu 6");
  442.                        WrStr(", Selection ");
  443.                        WrChar(Xch);
  444.                        WrStr(": Executed!");
  445.                        WrLn;
  446.                        WrLn;
  447.                        MenuIO.ExecCmd('pause')
  448.           END;(*CASE*)
  449.   | '7': Xch := MakeMenu(SubMenu7);
  450.           CASE Xch OF
  451.              '0'..'9': Clear;
  452.                        WrStr("SubMenu 7");
  453.                        WrStr(", Selection ");
  454.                        WrChar(Xch);
  455.                        WrStr(": Executed!");
  456.                        WrLn;
  457.                        WrLn;
  458.                        MenuIO.ExecCmd('pause')
  459.           END;(*CASE*)
  460.   | '8': Xch := MakeMenu(SubMenu8);
  461.           CASE Xch OF
  462.              '0'..'9': Clear;
  463.                        WrStr("SubMenu 8");
  464.                        WrStr(", Selection ");
  465.                        WrChar(Xch);
  466.                        WrStr(": Executed!");
  467.                        WrLn;
  468.                        WrLn;
  469.                        MenuIO.ExecCmd('pause')
  470.           END;(*CASE*)
  471.   | '9': Xch := MakeMenu(SubMenu9);
  472.           CASE Xch OF
  473.              '0'..'9': Clear;
  474.                        WrStr("SubMenu 9");
  475.                        WrStr(", Selection ");
  476.                        WrChar(Xch);
  477.                        WrStr(": Executed!");
  478.                        WrLn;
  479.                        WrLn;
  480.                        MenuIO.ExecCmd('pause')
  481.           END;(*CASE*)
  482.   | '0': Xch := MakeMenu(SubMenu10);
  483.           CASE Xch OF
  484.              '0'..'9': Clear;
  485.                        WrStr("SubMenu 10");
  486.                        WrStr(", Selection ");
  487.                        WrChar(Xch);
  488.                        WrStr(": Executed!");
  489.                        WrLn;
  490.                        WrLn;
  491.                        MenuIO.ExecCmd('pause')
  492.           END;(*CASE*)
  493.    END(*CASE*)
  494.  END MenuAction;
  495.  
  496.  (* Run program *)
  497.  
  498.  BEGIN
  499.    MainMenuLabel(MainMenu); (* initialize *)
  500.    M1(SubMenu1);
  501.    M2(SubMenu2);
  502.    M3(SubMenu3);
  503.    M4(SubMenu4);
  504.    M5(SubMenu5);
  505.    M6(SubMenu6);
  506.    M7(SubMenu7);
  507.    M8(SubMenu8);
  508.    M9(SubMenu9);
  509.    M10(SubMenu10);
  510.  
  511.    LOOP
  512.      Clear;
  513.  
  514.      GotoXY(30,3);
  515.        WrStr("<Esc> key exits program");
  516.      GotoXY(3,18);
  517.        WrStr("Press   arrow keys, PgUp/Dn or Home/End keys to highlight then press Enter");
  518.      GotoXY(9,20);
  519.        WrStr("Or press the number (top row number key) of desired selection > ");
  520.  
  521.      Xch := MakeMenu(MainMenu);
  522.      IF Xch = esc THEN EXIT END;(*IF*)
  523.      MenuAction(MainMenu) (* execute selection *)
  524.    END;(*LOOP*)
  525.    Clear
  526.  END menu3.